home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / fielddh.exe / DATES.PAS < prev    next >
Pascal/Delphi Source File  |  1992-03-24  |  25KB  |  682 lines
  1. {$F+,O+}
  2. UNIT Dates;
  3.  
  4.   { Version 1R0 - 1991 03 25                                               }
  5.   {         1R1 - 1991 04 09 - corrected several bugs, and                 }
  6.   {                          - deleted <JulianDa2>, <Da2OfWeek> and        }
  7.   {                            <JulianDa2ToDate> - all found to be not     }
  8.   {                            completely reliable.                        }
  9.  
  10. INTERFACE
  11.  
  12.   { These routines all assume that the year (y, y1) value is supplied in a }
  13.   { form that includes the century (i.e., in YYYY form).  No checking is   }
  14.   { performed to ensure that a month (m, m1) value is in the range 1..12   }
  15.   { or that a day (d, d1) value is in the range 1..28,29,30,31.  The       }
  16.   { FUNCTION ValidDate may be used to check for valid month and day        }
  17.   { parameters. FUNCTION DayOfYearToDate returns month and day (m, d) both }
  18.   { = 0 if the day-of-the-year (nd) is > 366 for a leap-year or > 365 for  }
  19.   { other years.                                                           }
  20.  
  21.   { NOTE: As written, FUNCTION Secs100 requires the presence of a 80x87    }
  22.   { co-processor.  Its declaration and implementation may be altered to    }
  23.   { REAL to make use of the floating-point emulation.                      }
  24.  
  25.   { Because the Gregorian calendar was not implemented in all countries at }
  26.   { the same time, these routines are not guaranteed to be valid for all   }
  27.   { dates. The real utility of these routines is that they will not fail   }
  28.   { on December 31, 1999 - as will many algorithms used in MIS programs    }
  29.   { implemented on mainframes.                                             }   
  30.  
  31.   { The routines are NOT highly optimized - I have tried to maintain the   }
  32.   { style of the algorithms presented in the sources I indicate. Any       }
  33.   { suggestions for algorithmic or code improvements will be gratefully    }
  34.   { accepted.  This implementation is in the public domain - no copyright  }
  35.   { is claimed.  No warranty either express or implied is given as to the  }
  36.   { correctness of the algorithms or their implementation.                 }
  37.  
  38.   { Author: Charles B. Chapman, London, Ontario, Canada [74370,516]        }
  39.   { Thanks to Leonard Erickson who supplied a test suite of values.        }
  40.  
  41.   FUNCTION IsLeap (y : WORD) : BOOLEAN;
  42.  
  43.   FUNCTION ValidDate (y, m, d : WORD) : BOOLEAN;
  44.   FUNCTION ValidDate_Str (Str         : string;                     {DWH}
  45.                           VAR Y, M, D : word;
  46.                           VAR Err_Str : string) : boolean;
  47.   FUNCTION ValidTime_Str (Str         : string;                     {DWH}
  48.                           VAR H, M, S : word;
  49.                           VAR Err_Str : string) : boolean;
  50.  
  51.   FUNCTION DayOfYear (y, m, d : WORD) : WORD;
  52.   FUNCTION JulianDay (y, m, d : WORD) : LONGINT;
  53.   FUNCTION JJ_JulianDay (y, m, d : word) : LONGINT;                 {DWH}
  54.  
  55.   FUNCTION DayOfWeek (y, m, d : WORD) : WORD;
  56.   FUNCTION DayOfWeek_Str (y, m, d : WORD) : String;                 {DWH}
  57.  
  58.   FUNCTION TimeStr   (h, m, s, c : WORD) : STRING;
  59.   FUNCTION TimeStr2  (h, m, s : WORD) : STRING;
  60.   FUNCTION SIDateStr (y, m, d : WORD; SLen : BYTE; FillCh : CHAR) : STRING;
  61.   FUNCTION MDYR_Str  (y, m, d : WORD): STRING;                      {DWH}
  62.  
  63.   FUNCTION Secs100 (h, m, s, c : WORD) : DOUBLE;
  64.   PROCEDURE DayOfYearToDate (nd, y : WORD; VAR m, d : WORD);
  65.  
  66.   PROCEDURE JulianDayToDate (nd : LONGINT; VAR y, m, d : WORD);
  67.   PROCEDURE JJ_JulianDayToDate (nd : LONGINT; VAR y, m, d : WORD);  {DWH}
  68.  
  69.   PROCEDURE DateOfEaster (Yr : WORD; VAR Mo, Da : WORD);
  70.   PROCEDURE AddDays (y, m, d : WORD; plus : LONGINT; VAR y1, m1, d1 : WORD);
  71.  
  72.   FUNCTION Lotus_Date_Str (nd : LONGINT) : string;                  {DWH}
  73. {==========================================================================}
  74.  
  75. IMPLEMENTATION
  76.   USES
  77.     Dos;
  78.  
  79. {==========================================================================}
  80.  
  81.   FUNCTION IsLeap (y : WORD) : BOOLEAN;
  82.  
  83.   { Returns TRUE if <y> is a leap-year                                     }
  84.  
  85.   BEGIN
  86.     IF y MOD 4 <> 0 THEN
  87.       IsLeap := FALSE
  88.     ELSE
  89.       IF y MOD 100 = 0 THEN
  90.         IF y MOD 400 = 0 THEN
  91.           IsLeap := TRUE
  92.         ELSE
  93.           IsLeap := FALSE
  94.       ELSE
  95.         IsLeap := TRUE
  96.   END;  { IsLeap }
  97.  
  98. {==========================================================================}
  99.  
  100.   FUNCTION DayOfYear (y, m, d : WORD) : WORD;
  101.  
  102.   { function IDAY from remark on CACM Algorithm 398                        }
  103.   { Computes day of the year for a given calendar date                     }
  104.   { GIVEN:   y - year                                                      }
  105.   {          m - month                                                     }
  106.   {          d - day                                                       }
  107.   { RETURNS: day-of-the-year (1..366, given valid input)                   }
  108.  
  109.   VAR
  110.     yy, mm, dd, Tmp1 : LONGINT;
  111.   BEGIN
  112.     yy := y;
  113.     mm := m;
  114.     dd := d;
  115.     Tmp1 := (mm + 10) DIV 13;
  116.     DayOfYear :=  3055 * (mm + 2) DIV 100 - Tmp1 * 2 - 91 +
  117.                   (1 - (yy - yy DIV 4 * 4 + 3) DIV 4 +
  118.                   (yy - yy DIV 100 * 100 + 99) DIV 100 -
  119.                   (yy - yy DIV 400 * 400 + 399) DIV 400) * Tmp1 + dd
  120.   END;  { DayOfYear }
  121.  
  122. {==========================================================================}
  123.  
  124.   FUNCTION JulianDay (y, m, d : WORD) : LONGINT;
  125.  
  126.   { procedure JDAY from CACM Alorithm 199                                  }
  127.   { Computes Julian day number for any Gregorian Calendar date             }
  128.   { GIVEN:   y - year                                                      }
  129.   {          m - month                                                     }
  130.   {          d - day                                                       }
  131.   { RETURNS: Julian day number (astronomically, for the day                }
  132.   {          beginning at noon) on the given date.                         }
  133.  
  134.   VAR
  135.     Tmp1, Tmp2, Tmp3, Tmp4, Tmp5 : LONGINT;
  136.   BEGIN
  137.     IF m > 2 THEN
  138.       BEGIN
  139.         Tmp1 := m - 3;
  140.         Tmp2 := y
  141.       END
  142.     ELSE
  143.       BEGIN
  144.         Tmp1 := m + 9;
  145.         Tmp2 := y - 1
  146.       END;
  147.     Tmp3 := Tmp2 DIV 100;
  148.     Tmp4 := Tmp2 MOD 100;
  149.     Tmp5 := d;
  150.     JulianDay := (146097 * Tmp3) DIV 4 + (1461 * Tmp4) DIV 4 +
  151.                  (153 * Tmp1 + 2) DIV 5 + Tmp5 + 1721119
  152.   END;  { JulianDay }
  153.  
  154. {==========================================================================}
  155.   
  156.   PROCEDURE DayOfYearToDate (nd, y : WORD; VAR m, d : WORD);
  157.                                                          
  158.   { procedure CALENDAR from CACM Algorithm 398                             }
  159.   { Computes month and day from given year and day of the year             }
  160.   { GIVEN:   nd - day-of-the-year (1..366)                                 }
  161.   {          y - year                                                      }
  162.   { RETURNS: m - month                                                     }
  163.   {          d - day                                                       }
  164.  
  165.   VAR
  166.     Tmp1, Tmp2, Tmp3, Tmp4, DaYr : LONGINT; 
  167.   BEGIN
  168.     DaYr := nd;
  169.     IF (DaYr = 366) AND (DayOfYear (y, 12, 31) <> 366) THEN
  170.       DaYr := 999;
  171.     IF DaYr <= 366 THEN
  172.       BEGIN
  173.         IF y MOD 4 = 0 THEN
  174.           Tmp1 := 1
  175.         ELSE
  176.           Tmp1 := 0;
  177.         IF (y MOD 400 = 0) OR (y MOD 100 <> 0) THEN
  178.           Tmp2 := Tmp1
  179.         ELSE
  180.           Tmp2 := 0;
  181.         Tmp1 := 0;
  182.         IF DaYr > Tmp2 + 59 THEN
  183.           Tmp1 := 2 - Tmp2;
  184.         Tmp3 := DaYr + Tmp1;
  185.         Tmp4 := ((Tmp3 + 91) * 100) DIV 3055;
  186.         d := ((Tmp3 + 91) - (Tmp4 * 3055) DIV 100);
  187.         m := (Tmp4 - 2)
  188.       END
  189.     ELSE
  190.       BEGIN
  191.         d := 0;
  192.         m := 0
  193.       END
  194.   END;  { DayOfYearToDate }
  195.  
  196. {==========================================================================}
  197.  
  198.   PROCEDURE JulianDayToDate (nd : LONGINT; VAR y, m, d : WORD);
  199.  
  200.   { procedure JDATE from CACM Algorithm 199                                }
  201.   { Computes calendar date from a given Julian day number for an